perm filename RESTS.OLD[MSS,LCS] blob sn#174115 filedate 1975-08-14 generic text, type T, neo UTF8
00100		SUBROUTINE RESTS
00200		COMMON/STF/RSTFAC(-3/4),RSTJ2 /XXX/LK,LP,JY
00300		COMMON/XRN/RN(2000),XN(2000)
00400		COMMON RS,JA,REST,J2,RQ(18),JX,JR,LX,RDIS
00500		COMMON/POSI/STFF(-3/4),JJ2,PQ/PTR/PWDS(250),L,LL,I,IX
00600		EQUIVALENCE (RQ(10),XLFT),(R5,RQ(3)),(R6,RQ(4)),(R7,RQ(5))
00700	C  RQ(3) IS R5 ETC.
00800		REST=0
00900		JA=0
01100		K=LX
01200	5	JL=PWDS(K)
01300		R=RN(JL+1)
01400		IF(R.NE.8)GO TO 232
01500		XLFT=RN(JL+3)
01600		GO TO 231
01700	232	IF(R.NE.1)GO TO 8
01800	4	IF(JA.EQ.0)JA=-1
01900		IF(JA.LE.-2)JA=-JA
02000		IF(JA.EQ.1)JA=-JA
02050		GO TO 231
02100	8	IF(R.NE.2)GO TO 231
02200		IF(RN(JL).LT.6)GO TO 4
02300	C FOUND A WHOLE REST MEAS.
02400		IF(REST.NE.0)GO TO 6
02500		IF(JA)JA=1
02600	C RESTS START AFTER NOTES
02700		IF(JA.EQ.0)JA=-2
02750		IF(JA.GE.2)JA=-3
02800		JR=JL+8
02900	C  POINTER TO REST NUM.
03000		RN(JR-1)=RN(JR-1)*.6
03100	C  REDUCE SIZE OF REST'S TIME SO IT WILL TAKE LESS SPACE.
03200	6	REST=REST+1
03300		RN(JR)=REST
03400		IF(JA.GE.2)JA=-3
03410		JL=K+2
03455		IF(JL.GE.L)RETURN
03500		LB=PWDS(JL)
03600		IF(RN(LB+1).NE.2)GO TO 233
03700	C NEXT IS TO COMBINE MEASURES OF REST
03800		IF(RN(LB).LT.6)GO TO 233
03900	C  SKIP NON-WHOLE RESTS
04000		N=PWDS(K+1)
04100		IF(RN(N+1).NE.4)GO TO 233
04200	C  IS REST FOLLOWED BY A BAR?
04300	CCC	RN(LB+1)=0
04400	C SO IT WON'T BE FOUND NEXT TIME AROUND.
04500		RN(LB+3)=-99
04600	C  MOVE IT FAR LET
04700	CCC	LB=PWDS(K+1)
04800		RN(N+3)=-99
04900	C  MOVES PPEV. BAR ALSO
05000		K=JL
05100		GO TO 5
05200	
05300	233	REST=0
05400	231	K=K+1
05500		IF(K.LT.L)GO TO 5
05600		END
05700	
05800		SUBROUTINE DELE
05900		COMMON/XRN/RN(2000),XN(2000)
06000		COMMON/STF/RSTFAC(-3/4),RSTJ2 /XXX/LK,LP,JY
06100		COMMON RS,JA,REST,J2,RQ(18),JX,JR,LX,RDIS
06200		COMMON/POSI/STFF(-3/4),JJ2,PQ/PTR/PWDS(250),L,LL,I,IX
06300		EQUIVALENCE (RQ(10),XLFT),(R5,RQ(3)),(R6,RQ(4)),(R7,RQ(5))
06400	C  NEXT DELETES UNWANTED ITEMS
06500		K=LX
06510	CC	RN(IFIX(PWDS(L))+3)=200
06600	1	J=PWDS(K)
06700		RZ=RN(J+3)
06750		R5=RN(J+1)
06800		IF(R5.NE.5)GO TO 7
06900	C  IS IT A SLUR?
07000		IF(RN(J+6).GT.200)RN(J+6)=199.99
07100	C  .LT. XLFT IS OK FOR SLUR, BUT RT. SIDE MUST BE .LE. 200
07200		GO TO 2
07210	7	IF(R5.NE.3)GO TO 9
07220		IF(RN(J).LT.3)GO TO 9
07230	C WDCNT TOO SMALL
07240		IF(RN(J+5).EQ.4)GO TO 8
07250	C DELETES CURVED BRACKET
07300	9	IF(RZ.GE.XLFT)GO TO 2
07400	8	N=PWDS(K+1)-J
07500		DO 3 M=J,IFIX(PWDS(L))
07600	3	RN(M)=RN(M+N)
07700		RZ=N
07800		DO 4 M=K+1,L-1
07900	4	PWDS(M)=PWDS(M+1)-RZ
07910	C  SHIFTS PWDS BACK A NOTCH
08000		L=L-1
08200	CC	LK=LK-N
08275	C  POINTS TO LAST SIGNIFICANT ITEM.
08400	CCC	JY=LK
08500	C  SHOULD THESE EVER BE DIFFERENT?????
08510		IF(L-1.GT.K)GO TO 1
08520		LK=PWDS(L)
08540		LP=LK
08600		RETURN
08700	
08800	2	IF(RZ.GE.200)RN(J+3)=199.99
08900	C  NOTHING CAN START PAST 200.
09000	 	K=K+1
09100		IF(K.LT.L)GO TO 1
09200		END
09300	
09400		FUNCTION R4567(R)
09500		R4567=0
09600		IF(R.LT.4)GO TO 1
09700		IF(R.LE.7)RETURN
09800	1	R4567=-1
09900		END
10000	
10100		SUBROUTINE BMQ(RN,NZ,A)
10200		DIMENSION RN(1)
10300		RR=RN(NZ)
10400		IF(RR.LT.7)RETURN
10500	C  FOR IRREGULAR BEAMS (THERE ARE AT LEAST 9 PARAMS.)
10600		IF(RR.NE.7)GO TO 129
10700	429	IF(RN(NZ+8).NE.0)GO TO 229
10800		RETURN
10900	129	IF(RN(NZ+10).EQ.0)GO TO 429
11000		IF(RN(NZ+10).LT.30)GO TO 229
11100		RB=RN(NZ+8)
11200		IF(RB.GT.A)RN(NZ+8)=BMX(RB,A)
11300	229	RB=RN(NZ+9)
11400		IF(RB.GT.A)RN(NZ+9)=BMX(RB,A)
11500		END
11600	
11700		FUNCTION BMX(RB,A)
11800		COMMON /PX/POS,SX
11900		BMX=RB+SX
12000		IF(A.EQ.-1000.)BMX=POSX(RB)
12100		END
12200	
12300		FUNCTION POSX(R)
12400		COMMON /PX/POS,SX
12500		POSX=POS+(R-POS)*SX
12600		END
12700	
12800		FUNCTION RCLEF(R)
12900		DIMENSION R(1)
13000		RCLEF=0
13100		IF(R(2).NE.3)RETURN
13150	C  IS IT A 'CLEF'?
13200		IF(R(1).LT.3)RETURN
13250	C  IS THE WDCNT BIG ENOUGH?
13300		IF(R(6).LE.3)RETURN
13400	C  FINDS ONLY 'REAL' CLEFS IN CODE NUM.3
13500		RCLEF=-1
13600		END
13700	
13800		SUBROUTINE REST2(KA,KB,JRH,KP,XWDS)
13900		COMMON/XRN/RN(2000),XN(2000)
14000		COMMON RS,JA,REST,J2,RQ(18),JX,JR,LX,RDIS
14100		COMMON/POSI/STFF(-3/4),JJ2,PQ/PTR/PWDS(250),L,LL,I,IX
14200		DIMENSION XWDS(1)
14400	1	DO 6 N=LX,L
14500		LL=PWDS(N)
14600		IF(RN(LL+1).NE.2)GO TO 6
14700	C NEXT PUTS IT ON PREV. LINE.
14800		REST=RN(LL+8)
14900		GO TO 4
15000	6	CONTINUE
15100	
15200	C THIS LINE ALL RESTS
15300	4	DO 3 K=KB-1,1,-1
15400		LA=XWDS(K)
15500		IF(XN(LA+1).NE.2)GO TO 3
15550		IF(JRH.EQ.-2)GO TO 7
15575	C JUMP IF PREV. STAFF WAS ALL RESTS.
15600		XN(LA+8)=XN(LA+8)+REST
15800		IF(JA.NE.-2)GO TO 5
15900		LX=KA
16000	C DELETE THIS STAFF
16100		L=KB
16200		JA=JHR
16300	C SO IT THINKS IT JUST FINISHED THE PREVIOUS LINE.
16500		RETURN
16600	3	CONTINUE
16700		RETURN
16800	
16900	5	DO 2 K=N+2,L
17000		LL=PWDS(K)
17100		IF(RN(LL+1).GT.2)GO TO 2
17110		IF(RN(LL+3).EQ.-99.)GO TO 2
17120	C  SKIP IF MORE RESTS TO DELETE
17200		M=PWDS(N)+3
17210		LA=LL+3
17220		RZ=RN(M)
17225		RX=RN(LA)
17230		KL=K
17300	13	RN(LA)=RZ
17310		KL=KL+1
17320		LA=PWDS(KL)+3
17330		RY=RN(LA)-RX
17340		IF(RY.GT.1)GO TO 14
17345	C TO PICK NEARBY ITEMS
17350		RZ=RZ+RY
17360		GO TO 13
17400	14	RN(M)=-99
17410	12	N=N+1
17420		M=PWDS(N)+3
17430		RZ=RN(M)
17440		IF(RZ.EQ.-99.)GO TO 12
17450	C HAS IT ALREADY BEEN CHANGED?
17500		RN(M)=-99
17600		RETURN
17700	2	CONTINUE
17800	C WILL DELETE REST AND BAR. MOVE NOTE TO REST POS.
17900		RETURN
18000	
18100	7	RS=RS+1
18110		DO 11 KL=LX-1,1,-1
18120	C TO FIND START OF PREV. STAFF
18130		LA=XWDS(KL)
18135		IF(XN(LA+1).EQ.2)RN(LL+8)=REST+XN(LA+8)
18137	C  COMBINES REST FROM PREV. LINE WITH 1ST OF THIS LINE.
18140	11	IF(XN(LA+2).GT.RS)GO TO 10
18145		KL=0
18150	10	KL=KL+1
18200	CC	RZ=PWDS(LX)-PWDS(KL)
18202		RZ=XWDS(LX)-XWDS(KL)
18210	C DIFFERENCE IN ITEMS ON THIS AND PREV. STAFF.
18300		KZ=KL
18400		DO 8 K=LX,L
18500		PWDS(KZ)=PWDS(K)-RZ
18600		KZ=KZ+1
18700		N=PWDS(K)
18800	8	RN(N+2)=RS
18900	C  RESET STAFF NUM. 
19000	
19100		N=PWDS(KL)
19200		KP=PWDS(KZ-1)
19300		KZ=RZ
19400		DO 9 K=N,KP
19500	9	RN(K)=RN(K+KZ)
19600	CCC	LX=KL+L-LX
19700	CCC	KA=LX
19710	CCC	L=LX
19720		L=KL+L-LX
19730		LX=KL
19740		KB=0
19800	C  SO IT WILL GO THE RIGHT PLACE IN PARTS.
19850	CCC	KP=KP-RZ
19900		END